CU Amiga Super CD-ROM 11/CU Amiga Magazine's Super CD-ROM 11 (1997)(EMAP Images)(GB)(Track 1 of 3)[!][issue 1997-06].iso/cucd/programming/oberonv4/source/system/pictures.mod

Oberon Text | 1996-06-19 | 33KB | 842 lines

Syntax10.Scn.Fnt
ParcElems
Alloc
Syntax24b.Scn.Fnt
StampElems
Alloc
19 Jun 96
Syntax10b.Scn.Fnt
Syntax10i.Scn.Fnt
Syntax20b.Scn.Fnt
Syntax16b.Scn.Fnt
(* AMIGA *)
MODULE Pictures; (* cn, RD, OJ
IMPORT
    SYSTEM,Amiga,Files,E:=AmigaExec,G:=AmigaGraphics,I:=AmigaIntuition,Kernel,L:=AmigaLayers, O:=Console;
CONST
    black*=0; white*=15;
    replace*=0; (* The new graphical object completely replaces whatever was before in the destination area. *)
    paint*=1; (* The new graphical object is added to whatever was before in the dertination area. *)
    invert*=2; (* The new graphical object inverts whatever was before in the dertination area. The color specifies, which planes are affected (inverted) and which aren't *)
    PictFileId*=  - 4093;
    BitMapPtr=POINTER TO G.BitMap;
    LayerPtr=POINTER TO G.Layer;
    RastPortPtr=POINTER TO G.RastPort;
    WindowPtr=POINTER TO I.Window;
    ScreenPtr=POINTER TO I.Screen;
    ColMem=ARRAY 256 OF RECORD r, g, b: CHAR END;
    Pattern*=LONGINT;
    Picture*=POINTER TO PictureDesc;
    Notifier*=PROCEDURE (P: Picture; X, Y, W, H : INTEGER);
    PictureDesc*=RECORD
        width*,height*,depth*:INTEGER;
        notify*:Notifier;
        bitMap:G.BitMap; (* Used only in CreateLayer, FreeLayer; V<39*)
        bitMapPtr:G.BitMapPtr; (* Used only in CreateLayer, FreeLayer; V>=39*)
        layer:G.LayerPtr;
        layerInfo: G.LayerInfoPtr; (* Used only in CreateLayer, FreeLayer *)
        rp*: G.RastPortPtr;
        pal: ColMem;
        oldCol:INTEGER;
        oldMode:INTEGER
    END ;
    Frame*=POINTER TO FrameDesc;
    FrameMsg*=RECORD END;
    Handler*=PROCEDURE (f: Frame; VAR msg: FrameMsg);
    FrameDesc*=RECORD
        dsc*, next*: Frame;
        X*, Y*, W*, H*: INTEGER;
        handle*: Handler
    END;
    PatternNode=POINTER TO RECORD
        p: Amiga.PatternInfoPtr;
        next: PatternNode
    END;
    dots*: Pattern;
    ToPrint*: Picture;
    rev: ARRAY 16 OF INTEGER;
    defaultPicture:Picture;
    nofCols, depthMask:INTEGER; (* depthMask:=nofCols-1 *)
    patternRoot:PatternNode;
    DispColBuffer: ColMem;
    DrMode: ARRAY 3 OF SHORTINT;    (* conversion table, used in SetDrawMode *)        (*<<OJ*)
    MinTerm: ARRAY 3 OF CHAR;    (* conversion table, used in CopyBlock *)
PROCEDURE SetDisplayColor*(col, red, green, blue: INTEGER); (*col < 0: overlay color not supported on the Amiga*)
    Set the RGB values for a screen color.
    scr:ScreenPtr;
    win: WindowPtr;
BEGIN
    IF Amiga.ModifyColors & (col<nofCols) & (col>=0) THEN
        win := SYSTEM.VAL(WindowPtr, Amiga.window);
        scr := SYSTEM.VAL(ScreenPtr, win.wScreen);
        G.SetRGB32(
            SYSTEM.VAL(G.ViewPortPtr,SYSTEM.ADR(scr.viewPort)),col+Amiga.ColorOffset,
            SYSTEM.LSH(LONG(red),24),SYSTEM.LSH(LONG(green),24),SYSTEM.LSH(LONG(blue),24)
END SetDisplayColor;
PROCEDURE GetDisplayColor*(col: INTEGER; VAR red, green, blue: INTEGER);
    Return the RGB values for a screen color.
    rgbTable:RECORD r,g,b:LONGINT END;
    scr:ScreenPtr;
    win: WindowPtr;
BEGIN
    win := SYSTEM.VAL(WindowPtr, Amiga.window);
    scr:=SYSTEM.VAL(ScreenPtr, win.wScreen);
    G.GetRGB32(scr.viewPort.colorMap,col MOD nofCols,1,rgbTable);
    red     := SHORT( SYSTEM.LSH(rgbTable.r,-24));
    green := SHORT( SYSTEM.LSH(rgbTable.g,-24));
    blue   := SHORT( SYSTEM.LSH(rgbTable.b,-24))
END GetDisplayColor;
PROCEDURE ColorsToScreen(m: ColMem);
    Copy colors from ColMem to screen
    VAR i: INTEGER;
BEGIN
    FOR i:=0 TO nofCols-1 DO
        SetDisplayColor(i, ORD(m[i].r), ORD(m[i].g), ORD(m[i].b))
END ColorsToScreen;
PROCEDURE GetScreenColors(VAR m: ColMem);
    Copy screen colors to ColMem
    VAR i, r, g, b: INTEGER;
BEGIN
    FOR i:=0 TO nofCols-1 DO
        GetDisplayColor(i, r, g, b);
        m[i].r:=CHR(r); m[i].g:=CHR(g); m[i].b:=CHR(b)
END GetScreenColors;
PROCEDURE UseOberonColors*(p: Picture);
    Store current screen colors to DispColBuffer and copy colors of Picture p to screen
BEGIN
    GetScreenColors(DispColBuffer);
    ColorsToScreen(p.pal)
END UseOberonColors;
PROCEDURE UseBufferedColors*;
    Copy colors from DispColBuffer to screen
BEGIN
    ColorsToScreen(DispColBuffer)
END UseBufferedColors;
PROCEDURE InitLayer(pic:Picture);
    Precondition: pic has already initialized depth, width and height fields.
    Creates bitmap and layer.
        l: LayerPtr;
        rp: RastPortPtr;
BEGIN
    rp:=SYSTEM.VAL(RastPortPtr, defaultPicture.rp);
    pic.bitMapPtr:=G.AllocBitMap(pic.width, pic.height, Amiga.Depth, {}, rp.bitMap);
    Amiga.Assert(pic.bitMapPtr#0,"Can't allocate BitMap");
    pic.layerInfo:=L.NewLayerInfo();
    Amiga.Assert(pic.layerInfo#0,"No layer info");
    pic.layer:=L.CreateUpfrontLayer(
        pic.layerInfo,pic.bitMapPtr,0,0,pic.width-1,pic.height-1,{G.layerSimple,G.layerBackdrop},0
    IF pic.layer=0 THEN HALT(70) END;
    l:=SYSTEM.VAL(LayerPtr,pic.layer);
    pic.rp:=l.rp
END InitLayer;
PROCEDURE FreeLayer(pic:Picture);
    Free layer and bitmap.
BEGIN
    IF pic.layer#0 THEN
        ASSERT(L.DeleteLayer(pic.layer));
        G.WaitBlit();
        pic.layer:=0
    END;
    IF pic.layerInfo#0 THEN L.DisposeLayerInfo(pic.layerInfo); pic.layerInfo:=0 END;
    G.FreeBitMap(pic.bitMapPtr);
    pic.oldCol:=-1;
    pic.oldMode:=-1;
    pic.depth:=0;
    pic.width:=0;
    pic.height:=0
END FreeLayer;
PROCEDURE WindowToPicture*(window:I.WindowPtr; VAR pic:Picture);
    Using this procedure you can create a picture which represents a windows
    contents. This procedure is only intended for use by Display.
    NOTE:
        never reuse this picture in a Pictures.Create call!
    bm:BitMapPtr;
    i:INTEGER;
    rp:RastPortPtr;
    w:WindowPtr;
BEGIN
    w:=SYSTEM.VAL(WindowPtr,window);
    NEW(pic);
    pic.width:=w.width-w.borderLeft-w.borderRight;
    pic.height:=w.height-w.borderTop-w.borderBottom;
    pic.rp:=w.rPort;
    rp:=SYSTEM.VAL(RastPortPtr,w.rPort);
    bm:=SYSTEM.VAL(BitMapPtr,rp.bitMap);
    pic.depth:=bm.depth;
    pic.notify:=NIL;
    FOR i:=0 TO pic.depth-1 DO
        pic.bitMap.planes[i]:=0; (* Used only in CreateLayer, FreeLayer *)
    END;
    pic.layer:=w.wLayer;
    pic.layerInfo:=0; (* Used only in CreateLayer, FreeLayer *)
    pic.oldCol:=-1;
    pic.oldMode:=-1;
    defaultPicture:=pic; (* Remember Oberon screen for DisplayBlock. I hate Pictures/Display! cn *)
END WindowToPicture;
PROCEDURE Finalize(obj: SYSTEM.PTR);
BEGIN
    FreeLayer(SYSTEM.VAL(Picture,obj))
END Finalize;
PROCEDURE Address*(P: Picture): LONGINT;
    Not supported at the Amiga, returns 0
    This PROCEDURE has a side effect. It stores the Picture in ToPrint.
    It is used for Printing Pictures.
BEGIN
    ToPrint:=P;
    RETURN 0
END Address;
PROCEDURE SetDrawMode(pic:Picture; col, mode: INTEGER); (* Faster and Shorter << OJ *)
    Ckeck old DrawModes (Mode, Color) and set new, if changed
    Every PROCEDURE drawing to a Picture has to call this
    WriteMsk has to be changed if mode changes to invert or (in mode invert) the color changes
BEGIN
    IF pic.oldMode # mode THEN
        pic.oldMode := mode;  G.SetDrMd(pic.rp, DrMode[mode]);
        pic.oldCol := col;
        col:=col MOD nofCols;
        IF mode=invert THEN
            G.SetWriteMask(pic.rp, col)
        ELSE
            G.SetWriteMask(pic.rp,depthMask);
            G.SetAPen(pic.rp, col+Amiga.ColorOffset)
        END
    ELSIF pic.oldCol # col THEN
        pic.oldCol := col;
        col:=col MOD nofCols;
        IF mode=invert THEN
            G.SetWriteMask(pic.rp, col)
        ELSE
            G.SetAPen(pic.rp, col+Amiga.ColorOffset)
        END
END SetDrawMode;
PROCEDURE CopyBlock*(sP, dP: Picture; SX, SY, W, H, DX, DY, mode: INTEGER);
    Copy a rectangular area within the display to another place. This procedure assumes, that any single
    area does not cross the boundary between primary and secondary screen.
BEGIN
    IF (W <= 0) OR (H <= 0) THEN RETURN END;
    SetDrawMode(dP, dP.oldCol, mode); (* only to set mask *)
    G.ClipBlit(sP.rp, SX, sP.height-SY(*-1*)-H,
                    dP.rp, DX, dP.height-DY(*-1*)-H, W, H, MinTerm[mode])        (*<<OJ*)
END CopyBlock;
PROCEDURE CopyBlockC*(sP, dP:Picture; f: Frame; SX, SY, W, H, DX, DY, mode: INTEGER);
    As CopyBlock, but the destination area is clipped against the Frame boundary.
    VAR dx, dy: INTEGER;
BEGIN
    IF (W <= 0) OR (H <= 0) THEN RETURN END;
    dx := f.X-DX;
    IF dx > 0 THEN INC(SX, dx); DX := f.X; DEC(W, dx) END;
    dx := DX+W-(f.X+f.W);
    IF dx > 0 THEN DEC(W, dx) END;
    dy := f.Y-DY;
    IF dy > 0 THEN INC(SY, dy); DY := f.Y; DEC(H, dy) END;
    dy := DY+H-(f.Y+f.H);
    IF dy > 0 THEN DEC(H, dy) END;
    IF (W > 0) & (H > 0) THEN CopyBlock(sP, dP, SX, SY, W, H, DX, DY, mode) END
END CopyBlockC;
PROCEDURE CopyPattern*(pic:Picture; col: INTEGER; pat: Pattern; X, Y, mode: INTEGER);
    Copy a pattern to the specified location.
    p: Amiga.PatternInfoPtr;
    wordStart:LONGINT;
    bitOffset:INTEGER;
    w, h:INTEGER;
BEGIN
    p := SYSTEM.VAL( Amiga.PatternInfoPtr, pat); w := p.w; h := p.h;
    IF (w > 0) & (h > 0) THEN
        SetDrawMode(pic, col, mode);
        wordStart:=p.data+p.offset DIV 8;
        bitOffset:=SHORT(p.offset MOD 8);
        IF ODD(wordStart) THEN
            DEC(wordStart);
            INC(bitOffset,8)
        END;
        G.BltTemplate(wordStart, bitOffset, p.modulo, pic.rp, X, pic.height-Y-h, w, h)
END CopyPattern;
PROCEDURE CopyPatternC*(pic:Picture; f: Frame; col: INTEGER; pat: Pattern; X, Y, mode: INTEGER);
    As CopyPattern, but clips the pattern against the frame boundary.
    dx, sx, dy, sy, w, h: INTEGER; p: Amiga.PatternInfoPtr;
    PROCEDURE copyPattern(pic:Picture; col: INTEGER; pat: Pattern; X, Y, dx, dy, w, h, mode: INTEGER);
        Routine used by CopyPattern and CopyPatternC. It will copy a pattern into the designated destination
        area. This routines is able to extract an arbitrary rectangular region from the origin pattern.
        p: Amiga.PatternInfoPtr;
        wordStart, bitIn:LONGINT;
        bitOffset:INTEGER;
    BEGIN
        p := SYSTEM.VAL( Amiga.PatternInfoPtr, pat);
        w := p.w+w; h := p.h+h;
        IF (w > 0) & (h > 0) THEN
            SetDrawMode(pic, col, mode);
            bitIn:=dx+p.offset;
            wordStart:=p.data+dy*p.modulo+bitIn DIV 8;
            bitOffset:=SHORT(bitIn MOD 8);
            IF ODD(wordStart) THEN
                DEC(wordStart);
                INC(bitOffset,8)
            END;
            G.BltTemplate(wordStart, bitOffset, p.modulo, pic.rp, X, pic.height-Y-h, w, h)
        END
    END copyPattern;
BEGIN
    p := SYSTEM.VAL(Amiga.PatternInfoPtr, pat);
    dx := f.X-X; sx := 0; sy := 0; w := p.w; h := p.h;
    IF dx > 0 THEN sx := dx; X := f.X; DEC(w, dx) END;
    dx := X+w-(f.X+f.W);
    IF dx > 0 THEN DEC(w, dx) END;
    dy := f.Y-Y;
    IF dy > 0 THEN Y := f.Y; DEC(h, dy) END;    (* don't adjust sy offset here. *)
    dy := Y+h-(f.Y+f.H);
    IF dy > 0 THEN sy := dy; DEC(h, dy) END;    (* adjust sy offset here, because of Amiga display model *)
    copyPattern(pic, col, pat, X, Y, sx, sy, w-p.w, h-p.h, mode)
END CopyPatternC;
PROCEDURE Dot*(pic:Picture; col: INTEGER; X, Y, mode: INTEGER);
    Change a single pixel.
BEGIN
    SetDrawMode(pic, col, mode);
    G.WritePixel(pic.rp, X, pic.height-Y-1)
END Dot;
PROCEDURE DotC*(pic:Picture; f: Frame; col: INTEGER; X, Y, mode: INTEGER);
     As Dot, but the the pixel is only written, if contained within the frame boundary.
BEGIN
    IF (X >= f.X) & (X < f.X+f.W) & (Y >= f.Y) & (Y < f.Y+f.H) THEN Dot(pic, col, X, Y, mode) END
END DotC;
PROCEDURE Get*(P: Picture; X, Y: INTEGER): INTEGER;
    Returns color of pixel at pos (X,Y)
    col:INTEGER;
BEGIN
    IF (X<0) OR (X>=P.width) OR (Y<0) OR (Y>=P.height) THEN RETURN black END ;
    IF P.oldMode=invert THEN
        P.oldMode:=replace;
        G.SetWriteMask(P.rp, depthMask);
        G.SetDrMd( P.rp, replace)
    END;
    col:=G.ReadPixel(P.rp,X,P.height-Y-1);
    RETURN col-Amiga.ColorOffset
END Get;
PROCEDURE Copy*(sP, dP: Picture; xs, ys, ws, hs, xd, yd, wd, hd, mode: INTEGER);
    Used to produce a scaled copy of a Picture
    VAR hx, hy, wd2, ws2: LONGINT; dx, dy, xso, xdo: INTEGER;
BEGIN
    dy:=yd + hd;  dx:=xd + wd; xso:=xs; xdo:=xd; wd2:=2*wd; ws2:=2*ws;
    hy:=2*hs - hd;
    WHILE yd < dy DO
        hx:=2*ws - wd; xd:=xdo; xs:=xso;
        WHILE xd < dx DO
            Dot(dP, Get(sP, xs, ys), xd, yd, mode);
            WHILE hx > 0 DO INC(xs); DEC(hx, wd2) END;
            INC(xd); INC(hx, ws2)
        END ;
        WHILE hy > 0 DO INC(ys); hy:=hy - 2*hd END;
        INC(yd); hy:=hy + 2*hs
END Copy;
PROCEDURE ReplConst*(pic: Picture; col, X, Y, W, H, mode: INTEGER);
    Generate a rectangle with the specified color and paint mode.
BEGIN
    IF (W <= 0) OR (H <= 0) THEN RETURN END;
    SetDrawMode(pic, col, mode);
    G.RectFill(pic.rp, X, pic.height-Y-H, X+W-1, pic.height-Y-1)
END ReplConst;
PROCEDURE ReplConstC*(pic: Picture; f: Frame; col: INTEGER; X, Y, W, H, mode: INTEGER);
    As ReplConst, but the rectangle is clipped against the frame boundary.
        dx, dy: INTEGER;
BEGIN
    IF (W <= 0) OR (H <= 0) THEN RETURN END;
    dx := f.X-X;
    IF dx > 0 THEN X := f.X; DEC(W, dx) END;
    dx := X+W-(f.X+f.W);
    IF dx > 0 THEN DEC(W, dx) END;
    dy := f.Y-Y;
    IF dy > 0 THEN Y := f.Y; DEC(H, dy) END;
    dy := Y+H-(f.Y+f.H);
    IF dy > 0 THEN DEC(H, dy) END;
    IF (W >0) & (H > 0) THEN ReplConst(pic,col, X, Y, W, H, mode) END
END ReplConstC;
PROCEDURE ReplPattern*(pic: Picture; col: INTEGER; pat: Pattern; X, Y, W, H, mode: INTEGER);
    Fill the specified area with the pattern.
    x, y, w, h, X1, Y1: INTEGER; p: Amiga.PatternInfoPtr;
    wordStart:LONGINT;
    bitOffset:INTEGER;
BEGIN
    SetDrawMode(pic, col, mode);
    p := SYSTEM.VAL(Amiga.PatternInfoPtr, pat);
    X1 := X+W; Y1 := Y+H; y := Y;
    WHILE y < Y1 DO
        IF y+p.h > Y1 THEN h := Y1-y ELSE h := p.h END;
        x := X;
        WHILE x < X1 DO
            IF x+p.w > X1 THEN w := X1-x ELSE w := p.w END;
            (*AdjustPointer(p.data+(p.h-h)*p.modulo,p.offset,wordStart,bitOffset);*)
            wordStart:=p.data+(p.h-h)*p.modulo+p.offset DIV 8;
            bitOffset:=SHORT(p.offset MOD 8);
            IF ODD(wordStart) THEN
                DEC(wordStart);
                INC(bitOffset,8)
            END;
            G.BltTemplate(wordStart, bitOffset, p.modulo, pic.rp, x, pic.height-y-h, w, h);
            x := x+p.w
        END;
        y := y+p.h
END ReplPattern;
PROCEDURE Min(x, y: INTEGER): INTEGER;
BEGIN IF x < y THEN RETURN x ELSE RETURN y END
END Min;
PROCEDURE Max(x, y: INTEGER): INTEGER;
BEGIN IF x > y THEN RETURN x ELSE RETURN y END
END Max;
PROCEDURE ReplPatternC*(pic:Picture; f: Frame; col: INTEGER; pat: Pattern; X, Y, W, H, X0, Y0, mode: INTEGER);
(* Replicates a pattern pat within the block (X, Y, W, H), clipped against F. The pattern origin is X0, Y0; i.e. for each
    completely visible occurrence of the pattern pat the following holds: ((x - X0) MOD w = 0) & ((y-Y0) MOD h = 0)
    where (x, y) denotes the left and bottom corner, and (w, h) the size of the pattern. *)
    rectangle: G.Rectangle; region, oldRegion: G.RegionPtr; p: Amiga.PatternInfoPtr;
    dx, dy: INTEGER;
BEGIN
    IF (W <= 0) OR (H <= 0) THEN RETURN END;
    region := G.NewRegion();
    rectangle.minX := Max(f.X, X); rectangle.maxX := Min(f.X+f.W-1, X+W-1);
    rectangle.minY := Max(pic.height-f.Y-f.H, pic.height-Y-H);
    rectangle.maxY := Min(pic.height-f.Y-1, pic.height-Y-1);
    IF G.OrRectRegion(region, SYSTEM.ADR(rectangle)) THEN
        p := SYSTEM.VAL(Amiga.PatternInfoPtr, pat);
        dx := (X-X0) MOD p.w; dy := (Y-Y0) MOD p.h;
        oldRegion := L.InstallClipRegion(pic.layer, region);
        ReplPattern(pic, col, pat, X-dx, Y-dy, W+dx, H+dy, mode);
        region := L.InstallClipRegion(pic.layer, oldRegion);
        G.DisposeRegion(region)
END ReplPatternC;
PROCEDURE Update*(P: Picture; X, Y , W, H: INTEGER);
BEGIN
    IF P.notify # NIL THEN P.notify(P, X, Y, W, H) END
END Update;
PROCEDURE DisplayBlock*(P: Picture; X, Y, W, H, DX, DY, mode: INTEGER);
    I assume, this copies the picture to the screen.
BEGIN
    IF defaultPicture=NIL THEN
        HALT(54)
    ELSE
        CopyBlock(P,defaultPicture,X,Y,W,H,DX,DY,mode)
END DisplayBlock;
PROCEDURE ReadInt(VAR R: Files.Rider; VAR i: INTEGER);
VAR hi: SHORTINT; lo: CHAR; li: LONGINT;
BEGIN
    Files.Read(R, lo); Files.Read(R, hi); li:=ORD(lo) + 256*hi; i:=SHORT(li)
END ReadInt;
PROCEDURE WriteInt(VAR R: Files.Rider; i: INTEGER);
BEGIN
    Files.Write(R, CHR(i MOD 256)); Files.Write(R, CHR(i DIV 256 MOD 256))
END WriteInt;
PROCEDURE ReadPal(VAR R: Files.Rider; P: Picture; nofcol: LONGINT);
    col:LONGINT;
BEGIN
    FOR col:=0 TO nofcol-1 DO
        Files.Read(R, P.pal[col].r); Files.Read(R, P.pal[col].g); Files.Read(R, P.pal[col].b)
END ReadPal;
PROCEDURE WritePal(VAR R: Files.Rider; P: Picture; nofcol: LONGINT);
VAR col: LONGINT;
BEGIN
    FOR col:=0 TO nofcol-1 DO
        Files.Write(R, P.pal[col].r); Files.Write(R, P.pal[col].g); Files.Write(R, P.pal[col].b)
END WritePal;
PROCEDURE Define(P: Picture; width, height, depth: INTEGER);    (* set width, height, depth, next, pixmap *)
BEGIN
    IF (P.width # width) OR (P.height # height) OR (P.depth # depth) OR (P.layer=0) THEN
        IF (width=0) OR (height=0) OR (depth=0) THEN HALT(50) END ;
        IF P.layer # 0 THEN FreeLayer(P) ELSE Kernel.RegisterObject(P, Finalize) END ;
        P.width:=width; P.height:=height; P.depth:=depth;
        InitLayer(P);
        IF P.layer=0 THEN HALT(40) END;
        P.oldCol:=-1;
        P.oldMode:=-1
END Define;
PROCEDURE ReadData(VAR R: Files.Rider; P: Picture; exp, map, rv: BOOLEAN);
    Load run length encoded picture.
    ch,ch1:CHAR;
    k:INTEGER;
    x,y,yoff:INTEGER;
    width, height, depth: INTEGER;
    m:ARRAY 256 OF CHAR;
    r:G.RastPortPtr;
    rptr:RastPortPtr;
    bptr:BitMapPtr;
    bpr: LONGINT;
    planes: ARRAY 8 OF LONGINT;
    (* faster Version of Dot, only for ReadData *)
    PROCEDURE NDot(col, X, Y: INTEGER);
    BEGIN
        IF P.oldCol # col THEN P.oldCol := col; G.SetAPen(r, col+Amiga.ColorOffset) END;
        G.WritePixel(r, X, P.height-Y-1)
    END NDot;
    PROCEDURE Unpack(p: LONGINT);
        i: INTEGER;
        pixel: INTEGER;
    BEGIN
        i:=8;
        REPEAT
            IF ODD(p) THEN pixel:=white ELSE pixel:=black END;
            NDot(pixel,x,yoff-y-1); INC(x); p:=ASH(p,-1); DEC(i)
        UNTIL (i=0) OR (x=width)
    END Unpack;
    (* new unpack writes data direct to the planes *)
    PROCEDURE Unpack(p: INTEGER);
        VAR
            offset, count: LONGINT;
            b: SYSTEM.BYTE;
    BEGIN
        b:=swap[p];
        offset:=y*bpr+ASH(x,-3);
        IF Amiga.OberonDepth<5 THEN
            FOR count:=0 TO Amiga.OberonDepth-1 DO
                SYSTEM.PUT(planes[count]+offset, b)
            END
        ELSE
            FOR count:=0 TO 3 DO
                SYSTEM.PUT(planes[count]+offset, b)
            END;
            FOR count:=4 TO Amiga.OberonDepth-1 DO
                SYSTEM.PUT(planes[count]+offset, 0X)
            END
        END;
        INC(x, 8)
    END Unpack;
BEGIN
    r:=P.rp; Dot(P, 0, 0, 0, replace); (* needed for new Dot *)
    rptr:=SYSTEM.VAL(RastPortPtr, r);
    depth:=P.depth;
    height:=P.height;
    width:=P.width;
    yoff:=P.height-1;
    IF depth=1 THEN (* install everythink for new Unpack *)
        rptr:=SYSTEM.VAL(RastPortPtr, r);
        bptr:=SYSTEM.VAL(BitMapPtr, rptr.bitMap);
        bpr:=bptr.bytesPerRow;
        FOR k:=0 TO Amiga.OberonDepth DO
            planes[k]:=SYSTEM.VAL(LONGINT, bptr.planes[k])
        END
    END;
    IF map THEN
        (*WHILE k < 256 DO m[k] := CHR((k MOD 2)*15); INC(k) END ;
        m[12] := CHR(15); m[13] := CHR(0); m[14] := CHR(15)*)
        x:=SHORT(ASH(1,depth));m[0]:=0X;
        FOR k:=1 TO 255 DO
            m[k]:=CHR(k MOD x);
            IF m[k]=0X THEN m[k]:=0FX END
        END
    END;
    y:=0;
    FOR y:=0 TO height-1 DO
        x:=0;
        WHILE x<width  DO
            Files.Read(R,ch);
            k:=ORD(ch);
            IF k<128 THEN
                REPEAT
                    Files.Read(R,ch);
                    IF exp THEN
                        ch1:=CHR(ORD(ch) MOD 16);
                        ch:=CHR(ORD(ch) DIV 16);
                        IF map THEN
                            ch1:=m[ORD(ch1)];
                            ch:=m[ORD(ch)]
                        END;
                        NDot(ORD(ch1),x,yoff-y);
                        INC(x)
                    ELSIF map THEN
                        ch:=m[ORD(ch)]
                    ELSIF rv THEN
                        ch:=CHR(rev[ORD(ch) DIV 16]+rev[ORD(ch) MOD 16]*16)
                    END;
                    IF x<width THEN
                        IF (depth=1) & ~map THEN
                            Unpack(ORD(ch))
                        ELSE
                            NDot(ORD(ch),x,yoff-y);
                            INC(x)
                        END
                    END ;
                    DEC(k)
                UNTIL k<0
            ELSE
                k:=257-k;
                Files.Read(R, ch);
                IF exp THEN
                    ch1:=CHR(ORD(ch) MOD 16);
                    ch:=CHR(ORD(ch) DIV 16);
                    IF map THEN
                        ch1:=m[ORD(ch1)];
                        ch:=m[ORD(ch)]
                    END
                ELSIF map THEN
                    ch:=m[ORD(ch)]
                ELSIF rv THEN
                    ch:=CHR(rev[ORD(ch) DIV 16]+rev[ORD(ch) MOD 16]*16)
                END ;
                REPEAT
                    IF exp THEN
                        NDot(ORD(ch1),x,yoff-y);
                        INC(x)
                    END;
                    IF x < width THEN
                        IF (depth=1) & ~map THEN
                            Unpack(ORD(ch))
                        ELSE
                            NDot(ORD(ch),x,yoff-y);
                            INC(x)
                        END
                    END;
                    DEC(k)
                UNTIL k<1
            END
        END
    END;
    G.SetWriteMask(P.rp, 0)
END ReadData;
PROCEDURE Load*(P: Picture; F: Files.File; pos: LONGINT; VAR len: LONGINT);
    Load a pictures which was identified as starting with a PictFileId.
    expand,map:BOOLEAN;
    R:Files.Rider;
    width,height,depth:INTEGER;
BEGIN
    Files.Set(R,F,pos); ReadInt(R,width); ReadInt(R,height); ReadInt(R,depth);
    ReadPal(R,P,ASH(1,depth)); (* RGB-Werte der Originalfarben laden *)
    expand:=FALSE;
    map:=FALSE;
    IF depth=4 THEN (* Ceres color picture *)
        expand:=TRUE;
        map:=Amiga.OberonDepth#4;
        depth:=Amiga.OberonDepth
    ELSIF depth>Amiga.OberonDepth THEN
        map:=TRUE;
        depth:=Amiga.OberonDepth
    END ;
    (* IF (depth#Amiga.Depth) & (depth#1) THEN HALT(43) END; *)
    Define(P,width,height,depth);
    ReadData(R,P,expand,map,FALSE);
    len:=Files.Pos(R)-pos
END Load;
PROCEDURE Store*(P: Picture; F: Files.File; pos: LONGINT; VAR len: LONGINT);
    stores picture to run length encoded file F   (including tag)
    a, b, x, y, width, height, depth, oridepth: INTEGER;
    j: LONGINT;
    h: CHAR;
    buf: ARRAY 129 OF CHAR;
    R: Files.Rider;
    PROCEDURE Pack(): CHAR;
        VAR i, j, p: INTEGER;
    BEGIN
        i:=8; j:=1; p:=0;
        REPEAT
            IF Get(P, x, P.height-y-1)#black THEN INC(p, j) END;
            INC(x); j:=j*2; DEC(i)
        UNTIL (i=0) OR (x=width);
        RETURN CHR(p)
    END Pack;
    (* store pictures with 4 planes in Ceres 4 colors-format *)
    PROCEDURE PackColor(): CHAR;
        VAR ch, ch1: INTEGER;
    BEGIN
        ch:=Get(P, x, P.height-y-1)-Amiga.ColorOffset; INC(x);
        ch1:=Get(P, x, P.height-y-1)-Amiga.ColorOffset; INC(x);
        RETURN CHR(ch+ch1*16)
    END PackColor;
BEGIN
    width:=P.width; height:=P.height; oridepth:=P.depth;
    (* only store as 1, 4 or 8 Plane Pict *)
    depth:=oridepth;
    IF (oridepth=2) OR (oridepth=3) THEN depth:=4 END;
    IF (oridepth>4) & (oridepth<7) THEN depth:=8 END;
    Files.Set(R, F, pos); WriteInt(R, PictFileId);
    WriteInt(R, width); WriteInt(R, height); WriteInt(R, depth);
    WritePal(R, P, ASH(1, depth));
    (* fill Colortabel with 0 *)
    IF depth#oridepth THEN
        FOR j:=1 TO (ASH(1, depth)-ASH(1, oridepth))*3 DO
            Files.Write(R, CHR(0))
        END
    END;
    y:=0;
    WHILE height > 0 DO x:=0; a:=0;
        j:=1; buf[0]:=0X;
        IF depth=1 THEN h:=Pack()
        ELSIF depth=4 THEN h:=PackColor()
        ELSE h:=CHR(Get(P, x, P.height-y-1)); INC(x)
        END ;
        b:=1; buf[j]:=h;
        WHILE x < width DO
            IF depth=1 THEN h:=Pack()
            ELSIF depth=4 THEN h:=PackColor()
            ELSE h:=CHR(Get(P, x, P.height-y-1)); INC(x)
            END;
            IF ((b - a) < 127) & ((buf[0]=0X) OR ((h=buf[j]) & (j=1)) OR ((h # buf[j]) & (j  > 1))) THEN (* same run *)
                IF h # buf[j] THEN INC(SYSTEM.VAL(SHORTINT, buf[0])); INC(j); buf[j]:=h
                ELSE DEC(SYSTEM.VAL(SHORTINT, buf[0])) END
            ELSE (* new run *)
                IF (buf[j]=h) & (b - a # 127) THEN DEC(SYSTEM.VAL(SHORTINT, buf[0])); Files.WriteBytes(R, buf, j); buf[0]:=0FFX
                ELSE Files.WriteBytes(R, buf, j + 1); buf[0]:=0X END ;
                j:=1; buf[j]:=h; a:=b
            END ;
            INC(b)
        END ;
        Files.WriteBytes(R, buf, j + 1);
        DEC(height); INC(y)
    END ;
    len:=Files.Pos(R) - pos
END Store;
PROCEDURE Create*(P: Picture; width, height, depth: INTEGER);
    Create a picture with the requested size. The main work is done
    in Define. This only clears the picture area and the color
    palette.
    col: INTEGER;
BEGIN
    Define(P, width, height, depth);
    ReplConst(P, black, 0, 0, P.width, P.height, replace);
    FOR col:=0 TO 255 DO P.pal[col].r:=0X; P.pal[col].g:=0X; P.pal[col].b:=0X END
END Create;
PROCEDURE Open*(P: Picture; name: ARRAY OF CHAR);
    Load a file into a picture.
    F:Files.File;
    R:Files.Rider;
    len: LONGINT;
    x, d: INTEGER;
    dname: ARRAY 64 OF CHAR;
BEGIN
    F:=Files.Old(name);
    IF F#NIL THEN
        Files.Set(R,F,0);
        x:=0;
        ReadInt(R,x);
        IF x=0 THEN (* MacPaint format *)
            Define(P,576,720,1);
            Files.Set(R,F,Files.Pos(R)+510);
            ReadData(R,P,FALSE,FALSE,TRUE)
        ELSIF x=PictFileId THEN
            Load(P,F,2,len)
        ELSIF x=07F7H THEN (* Skipping System3 File-Header *)
            Files.ReadString(R, dname); Files.ReadInt(R, d); Files.ReadInt(R, d); Files.ReadInt(R, d); Files.ReadInt(R, d);
            Files.ReadInt(R, x);
            IF x=PictFileId THEN
                Load(P, F, Files.Pos(R), len)
            ELSE
                O.Str("System3-File, Unknown format");O.Ln
            END
        ELSE
            O.Str("Unknown format");O.Ln
        END
    ELSE
        O.Str("Pictures.Open: "); O.Str(name); O.Str(" failed"); O.Ln;
        Create(P,Amiga.Width*5 DIV 8 -20,Amiga.Height-80,Amiga.OberonDepth)
END Open;
PROCEDURE SetColor*(P:Picture; col,red,green,blue:INTEGER);
    Change the RGB values of a palette entry.
BEGIN
    IF (col<nofCols) & (col>=0) THEN
        P.pal[col].r:=CHR(red); P.pal[col].g:=CHR(green); P.pal[col].b:=CHR(blue)
END SetColor;
PROCEDURE GetColor*(P: Picture; col: INTEGER; VAR red, green, blue: INTEGER);
    Retrieve the RGB values of a palette entry.
BEGIN
    IF (col<nofCols) & (col>=0) THEN
        red:=ORD(P.pal[col].r); green:=ORD(P.pal[col].g); blue:=ORD(P.pal[col].b)
END GetColor;
PROCEDURE NewPattern*(VAR image: ARRAY OF SET; w, h: INTEGER): Pattern;
(* Allocates a new pattern with width w and height h. The i-th pattern line from bottom (increasing y-value)
    corresponds to the image entries (i+1)*lineLen .. (i+2)*lineLen-1, where lineLen = (w+31) DIV 32.
    The set elements describe the pixels from left to right (increasing x-value). *)
CONST header=4;
        ch: CHAR; src, dest: LONGINT; byte, bytesPerRow, i, size: LONGINT;
        pattern: Amiga.PatternInfoPtr; patNode: PatternNode;
BEGIN
    Amiga.Assert((0<w) & (w<=32) & (0<h),"Illegal pattern size");
    NEW(pattern); pattern.w := SHORT(w); pattern.h := SHORT(h); pattern.modulo := 2*((w+15) DIV 16);
    NEW(patNode); patNode.next := patternRoot; patternRoot := patNode;
    patNode.p := pattern;    (* to insert pattern into global list for GC *)
    size := pattern.modulo*h;
    IF Amiga.ChipMemPool#0 THEN
        pattern.data:=E.AllocPooled(Amiga.ChipMemPool, size)
    ELSE
        pattern.data := E.AllocMem(size, {E.memChip})
    END;
    pattern.offset:=0;
    bytesPerRow := (w + 7) DIV 8;
    src := SYSTEM.ADR(image)+header+3; dest := pattern.data+pattern.modulo*(h-1);
    FOR i := 0 TO h-1 DO
        FOR byte := 1 TO bytesPerRow DO
            SYSTEM.GET(src, ch); SYSTEM.PUT(dest, Amiga.SwapBits[ORD(ch)]);
            DEC(src); INC(dest)
        END;
        DEC(dest, bytesPerRow+pattern.modulo);
        INC(src, bytesPerRow+4)
    END;
    RETURN SYSTEM.VAL(Pattern,pattern)
END NewPattern;
PROCEDURE Line*(pic:Picture; f:Frame; col, X0, Y0, X1, Y1, mode: INTEGER);
(* Draws a line from (X0, Y0) to (X1, Y1) inclusive, clipped against F.  For all line points (x, y) the following holds
always: (min(X0, X1) <= x) & (x <= max(X0, X1) & (min(Y0, Y0) <= y) & (y <= max(Y0, Y1). *)
    rectangle: G.Rectangle;
    region,oldRegion: G.RegionPtr;
BEGIN
    SetDrawMode(pic, col, mode);
    region := G.NewRegion();
    rectangle.minX := f.X; rectangle.maxX := f.X+f.W-1;
    rectangle.minY := pic.height-f.Y-f.H; rectangle.maxY := rectangle.minY+f.H-1;
    IF G.OrRectRegion(region, SYSTEM.ADR(rectangle)) THEN
        oldRegion := L.InstallClipRegion(pic.layer, region);
        G.Move(pic.rp,X0,pic.height-Y0-1);
        G.Draw(pic.rp,X1,pic.height-Y1-1);
        region := L.InstallClipRegion(pic.layer, oldRegion);
        G.DisposeRegion(region)
END Line;
PROCEDURE Ellipse*(pic:Picture; f:Frame; col, X, Y, A, B, mode: INTEGER);
(* Draws an ellipse with center (X, Y) and radii A and B, clipped against F. For all ellipse points (x, y)  the following holds
    always: (X-A <= x) & (x < X+A) & (Y-B <= y) & (y < Y+B). When A = B the resulting ellipse has the same shape
    as the corresponding circle with R = A. *)
    rectangle: G.Rectangle;
    region,oldRegion: G.RegionPtr;
BEGIN
    SetDrawMode(pic, col, mode);
    region := G.NewRegion();
    rectangle.minX := f.X; rectangle.maxX := f.X+f.W-1;
    rectangle.minY := pic.height-f.Y-f.H; rectangle.maxY := rectangle.minY+f.H-1;
    IF G.OrRectRegion(region, SYSTEM.ADR(rectangle)) THEN
        oldRegion := L.InstallClipRegion(pic.layer, region);
        G.DrawEllipse(pic.rp,X,pic.height-Y-1,A,B);
        region :=L.InstallClipRegion(pic.layer, oldRegion);
        G.DisposeRegion(region)
END Ellipse;
PROCEDURE Circle*(pic:Picture; f:Frame; col, X, Y, R, mode: INTEGER);
(* Draws a circle with center (X, Y) and radius R, clipped against F. For all circle points (x, y)  the following holds always:
    (X-R <= x) & (x < X+R) & (Y-R <= y) & (y < Y+R). *)
BEGIN
    Ellipse(pic,f,col,X,Y,R,R,mode)
END Circle;
PROCEDURE AmigaText*(P:Picture; font:G.TextFontPtr; VAR text: ARRAY OF CHAR; count, x, y, col, mode: INTEGER);
    Print text with Amiga font
BEGIN
    SetDrawMode(P, col, mode);
    G.Move(P.rp, x, P.height-y-1);
    G.SetFont(P.rp, font);
    G.Text(P.rp, text, count)
END AmigaText;
PROCEDURE Init;
    im: ARRAY 17 OF SET;
    k: INTEGER;
BEGIN
    defaultPicture:=NIL;
    nofCols:=SHORT(ASH(1, Amiga.OberonDepth));
    depthMask:=nofCols-1;
    DrMode[replace]:=G.jam2;  DrMode[paint]:=G.jam1;  DrMode[invert]:=G.complement;        (*<<OJ*)
    MinTerm[replace]:=0C0X;      (* dest := BC + B~C *)
    MinTerm[paint]:=0E0X;         (* dest := BC + ~BC + B~C *)
    MinTerm[invert]:=060X;        (* dest := B~C + ~BC *)
    patternRoot:=NIL;
    rev[0]:=0; rev[1]:=8; rev[2]:=4; rev[3]:=12;
    rev[4]:=2; rev[5]:=10; rev[6]:=6; rev[7]:=14;
    rev[8]:=1; rev[9]:=9; rev[10]:=5; rev[11]:=13;
    rev[12]:=3; rev[13]:=11; rev[14]:=7; rev[15]:=15;
    im[1]:={};
    im[2]:={1..7,9..15}; im[3]:=im[2]; im[4]:=im[2]; im[5]:=im[2];
    im[6]:=im[2]; im[7]:=im[2]; im[8]:=im[2]; im[9]:=im[1];
    im[10]:=im[2]; im[11]:=im[2]; im[12]:=im[2]; im[13]:=im[2];
    im[14]:=im[2]; im[15]:=im[2]; im[16]:=im[2];
    dots:=NewPattern(im, 16, 16)
END Init;
BEGIN
    Init
END Pictures.